home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
TPNDX_SK.ARJ
/
NDX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-23
|
18KB
|
444 lines
{$E+,I-,N+,R-,V- -80X87 emulation, no I/O errors,
no range checks}
UNIT NDX;
{***********************************************************************}
{ NDX.TPU RKB 91/01/19. }
{ This unit support reading, seeking and traversing dBase III }
{ .NDX files. }
{ dBase and dBase III are trademarks of Ashton-Tate Corp. }
{ Copyright (C) 1990-1991. Robert K. BLaine/ECONO-SOFT. }
{ All rights reserved. }
{ Permission is hereby granted to freely use these routines }
{ as long as this copyright remains intact. }
{***********************************************************************}
{=======================}INTERFACE{=============================}
CONST
MaxNDXKeyLength = 511 - 24 + 1; {***Bytes 24...511 of the header ***}
MaxNDXKeyValueLength = 100;
SetExact : Boolean = FALSE;
TYPE
NDXseekMode =
(NDXmodeSeekAll, {*** to traverse entire NDX ***}
NDXmodeSeekFirst, {*** for quick seek of first match ***}
NDXmodeSeekCall); {*** call UserProc for all matches ***}
Str13 = String [13];
Str66 = String [66];
KeyStr = String [MaxNDXKeyValueLength];
NDXheaderRec = Record
RootPage : Longint; {*** 0- 3: B+ tree root page number ***}
NextPage : Longint; {*** 4- 7: first unused page ***}
D0 : Longint; {*** 8-11: (Reserved) ***}
KeyLen : Word; {*** 12-13: Key length ***}
KeysPage : Word; {*** 14-15: keys per page ***}
NumericKey : Boolean; {*** 16: True if key is numeric *** }
D1 : Byte; {*** 17: (reserved) ***}
EntrySize : Word; {*** 18-19: Length of entry. ***}
D2 : Longint; {*** 20-23: (reserved) ***}
Key : ARRAY [1..MaxNDXKeyLength] OF Char;
END;
NDXpageRec = RECORD
NEntries : Integer; {* 0- 1: #active entries in this page *}
D0 : Integer;
Entries : ARRAY [0..507] OF Byte;
END;
{*****************************************************************}
{*** NDXentry Notes: ***}
{*** -if RecNo or LEpage are not used, they are set to 0. ***}
{*** -an entry has LEpage or RecNo but never both. ***}
{*** -mumeric and date keys are stored as 8-byte 80x87 Double. ***}
{*****************************************************************}
NDXentry = ^NDXentryRec;
NDXentryRec = Record
LEpage : Longint; {* 0- 3: page containing previous keys *}
RecNo : Longint; {*** 4- 7: record number matching Key ***}
Case Byte OF
1: (DoubleKey: Double);
2: (CharKey : ARRAY [1..MaxNDXKeyValueLength] OF Char);
END;
{********************************************************************}
{*** NDXpageInfo is used to keep position information within the ***}
{*** index file. Recursion is not used since the inkex could be ***}
{*** much larger than available memory. ***}
{********************************************************************}
NDXpageInfo = ^NDXpageInfoRec;
NDXpageInfoRec = Record
PageN : Longint; {*** page number ***}
Index : Integer; {*** index within page ***}
PrevPage: NDXpageInfo; {*** previous page ***}
END;
_NDX = Record {*** the .NDX file itself ***}
F : File; {*** the .NDX file header ***}
H : NDXheaderRec; {*** current index page ***}
CurrentPage : Longint;
Index : Integer; {*** index within the current page ***}
LastMatch : Longint; {*** last match on "Seek" ***}
Level : Integer; {*** current level of recursion ***}
MaxLevel : Integer; {*** maximum level of recursion ***}
NMatches : Integer; {*** # successful matches last "Seek" *}
PrevPages : NDXpageInfo; {*** list of previous pages ***}
END;
{**********************************************************}
{*** A routine of type "NDXProc" is called when traversing.}
{**********************************************************}
NDXproc = PROCEDURE(Var N: _NDX; Var entry: NDXentry);
PROCEDURE NDXopen(Var N: _NDX; fn: Str66);
PROCEDURE NDXclose(Var N: _NDX);
FUNCTION NDXgetKey(Var N: _NDX; Var entry: NDXentry; Limit: Integer): KeyStr;
FUNCTION NDXSeek(Var N: _NDX; Key: KeyStr): Longint;
FUNCTION NDXseekN(Var n: _NDX; Key: double): Longint;
PROCEDURE NDXseekAll(Var N: _NDX; UserProc: NDXProc; KEY: KeyStr);
PROCEDURE NDXseekALLN(Var N: _NDX; UserProc: NDXproc; Key: double);
PROCEDURE NDXTraverse(Var n: _NDX; UserProc: NDXproc);
{=========================}IMPLEMENTATION{===========================}
PROCEDURE ErrorExit(Msg: Str66);
Begin
Writeln(Msg);
Halt(1)
End;
(****************************************************************************)
PROCEDURE NDXopen(Var N: _NDX; fn: Str66);
{*********************************************************************}
{*** Open dBaseIII Index (.NDX) file. *** }
{*** entry conditions: *** }
{*** N= NDX control record *** }
{*** fn= file specification. *** }
{*** exit conditions: *** }
{*** Return : N = completely installed *** }
{*********************************************************************}
Var
SizeRead: Word;
Begin {NDXopen}
Assign(N.F, fn); Reset(N.F, 1);
IF IOResult <> 0 THEN
ErrorExit(' Could not open NDX.');
BlockRead (N.F, N.H, SizeOf (N.H), SizeRead);
IF (IOResult <> 0) OR (SizeRead< SizeOf (N.H)) THEN
ErrorExit(' Could not read NDX header Page.');
N.Level := 0;
N.MaxLevel := 0;
N.PrevPages := NIL;
END;
(****************************************************************************)
Procedure NDXclose(Var N: _NDX);
{**********************************************}
{*** Close A dBase II index (.NDX) file. ***}
{*** Entry conditions: ***}
{*** passed : N = NDX control record. ***}
{*** Exit conditions: ***}
{*** None. ***}
{**********************************************}
Begin {NDXclose}
Close(N.F);
IF IOResult <> 0 THEN
ErrorExit(' Could not close NDX.');
End;
FUNCTION NDXGetKey(Var N: _NDX; Var entry: NDXentry; Limit: Integer): KeyStr;
{*****************************************************************}
{*** Get the alphanumeric key associated with an index entry. ***}
{*** Entry conditions: ***}
{*** passed : N = NDX control record. ***}
{*** Entry = Pointer to an entry record. ***}
{*** Limit = length of key to return (0 = full length). ***}
{*** Exit conditions: ***}
{*** return : Alphanumeric key. ***}
{*****************************************************************}
Var
S: KeyStr;
Begin {NDXGetKey}
IF N.H.NumericKey THEN
NDXgetKey := ''
ELSE
Begin
IF (Limit = 0) OR (Limit > N.H.KeyLen) THEN
Limit := N.H.KeyLen;
Move(entry^.CharKey, S [1], Limit);
Byte(S [0]) := Limit; {*** Length of String ***}
NDXgetKey := S;
End;
End; {*** NDXgetKey ***}
(****************************************************************************)
Procedure NDXreadPage(Var N: _NDX; page: Longint; Var PageBuf: NDXpageRec);
{*********************************************}
{*** Read and NDX page. ***}
{*** entry conditions: ***}
{*** Passed : N = NDX control record. ***}
{*** Page = page number to read. ***}
{*** PageBuf = recieving buffer. ***}
{*** ***}
{*** Exit conditions: ***}
{*** None ***}
{*********************************************}
Var
BytesRead : Word;
Begin {*** NDXreadPage ***}
Seek (N.F, page SHL 9 {* 512});
If IOResult <> 0 Then
ErrorExit('Could not read requested index page.');
N.CurrentPage := page;
End; {*** NDXreadPage ***}
(****************************************************************************)
Procedure NDXseekPrim(Var N: _NDX;UserProc:NDXProc;Var Key; Mode:NDXseekMode);
{************************************************************************}
{*** Seek a dBase III Index (.NDX) file. "UserProc" is called ***}
{*** for every match in the index (unless Mode=SeekFirst). ***}
{*** ***}
{*** Entry conditions ***}
{*** Passed : N =NDX control record. ***}
{*** UserProc = user routine to process matches ***}
{*** Key = alphnumeric or numeric key. ***}
{*** Mode = SeekAll, SeekFirst, or SeekCall. ***}
{*** Exit conditions ***}
{*** None ***}
{*** Note: This routine is not interfaced and is not called directly. ***}
{************************************************************************}
Var
NextPage: Longint;
entry : NDXentry;
Found, Done : Boolean;
GTpage: ^Longint;
PageBuf: NDXpageRec;
Procedure PushPage(NewPage: Longint);
{*** Push NDX page information onto PageInfo list. ***}
Var
T: NDXpageInfo;
Begin {*** PushPage ***}
IF Mode <> NDXmodeSeekFirst Then {*** does not need to return}
Begin
GetMem (T, SizeOf(NDXpageInfoRec));
T^.Index := N.Index;
T^.PageN := N.CurrentPage;
T^.PrevPage := N.PrevPages;
N.PrevPages := T; {*** add to top of list ***}
End;
NextPage := NewPage; {*** will force page Read ***}
N.Index := 0;
End; {*** PushPage ***}
(****************************************************************************)
Procedure PopPage;
{*** Pop NDX page information off of PageInfo list. ***}
Var
T: NDXPageInfo;
Begin {*** PopPage ***}
If N.PrevPages <> NIL Then
Begin
N.Index := N.PrevPages^.Index;
NextPage := N.PrevPages^.PageN; {*** force re-read ***}
T := N.PrevPages^.PrevPage^.PrevPage;
FreeMem (N.PrevPages, SizeOf(NDXpageInfoRec));
N.PrevPages := T;
entry := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
End;
End; {*** PopPage ***}
Type
TestMode = (LE, EQ, GT);
{****************************************************************************}
Function TestKey(TMode: TestMode) : Boolean;
{*** Isolate tests for flexibility ***}
Begin
If Mode = NDXmodeSeekAll Then
TestKey := True {*** for full traverse ***}
Else If N.H.NumericKey Then
Case Tmode of
LE: TestKey := double(Key) <= entry^.DoubleKey;
EQ: TestKey := double(Key) <= entry^.DoubleKey;
GT: TestKey := double(Key) <= entry^.DoubleKey;
End {*** Case ***}
Else
Case Tmode Of
LE: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
EQ: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
GT: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
End; {*** Case ***}
End; {*** TestKey ***}
Begin {NDXseekPrim}
Found := False;
Done := False;
N.Index := 0;
N.LastMatch := 0;
N.Nmatches := 0;
If NOT N.H.NumericKey AND SetExact Then
While Length (KeyStr(Key)) < N.H.KeyLen Do
KeyStr(Key) := KeyStr(Key) + ' ';
NextPage := N.H.RootPage;
Repeat
NDXreadPage(N, NextPage, PageBuf);
NextPage := 0;
While (N.Index< PageBuf.NEntries) AND (NextPage = 0) AND NOT Done Do
Begin
entry := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
Inc (N.Index);
If entry^.LEpage <> 0 Then
IF TestKey(LE) Then
PushPage (entry^.LEPage);
If entry^.RecNo <> 0 Then
If TestKey (EQ) Then
Begin
Found := True;
Inc(N.NMatches);
N.LastMatch := entry^.RecNo;
If Mode = NDXmodeSeekFirst Then
Done := True
Else
UserProc(N, entry);
End
Else If found Then
Done := True;
End;
IF (NextPage = 0) AND (N.Index = PageBuf.NEntries) AND Not Done Then
Begin
GTPage := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
Inc(N.Index);
If GTPage^ <> 0 Then
If TestKey(GT) Then
PushPage (GTpage^);
End;
If NextPage = 0 Then
PopPage;
Until NextPage = 0
End;
(****************************************************************************)
Procedure NDXseekAll(Var N: _NDX; UserPRoc: NDXProc; Key: KeyStr);
{***********************************************************************}
{*** Seek a dBase III Index (.NDX) file calling the user routine for ***}
{*** each entry in the index that matches the key. ***}
{*** Entry Conditions: ***}
{*** Passed : N = NDX control record. ***}
{*** UserProc = user routine call. ***}
{*** Key = alphanumeric key. ***}
{*** Exit Conditions: ***}
{*** None ***}
{***********************************************************************}
Begin {*** NDXseekAll ***}
If N.H.NumericKey Then
ErrorExit(' Improper alphanumeric Seek.');
NDXseekPrim(N, UserProc, Key, NDXmodeSeekCall);
End; {*** NDXseekAll ***}
{****************************************************************************}
Procedure NDXseekAllN(Var N: _NDX; UserProc: NDXProc; Key: Double);
{***********************************************************************}
{*** Seek a dBase III Index (.NDX) file calling the user routine for ***}
{*** each entry in the index that matches the key. ***}
{*** Entry conditions:
{*** Passed : N = NDX control record. ***}
{*** UserProc = user routine call. ***}
{*** Key = numeric key. ***}
{*** Exit conditions: ***}
{*** None ***}
{***********************************************************************}
Begin {*** NDXseekAllN ***}
If NOT N.H.NumericKey THEN
ErrorExit('Improper numeric Seek.');
NDXseekPrim(N, USerProc, Key, NDXmodeSeekCall);
End;
{****************************************************************************}
{$F+} Procedure DummyUserProc(Var N: _NDX; Var entry: NDXentry);
{*** For use when Mode=SeekFirst ***}
Begin
Halt (1);
End;
{$F-}
{****************************************************************************}
Function NDXseek(Var N: _NDX; Key: KeyStr): Longint;
{***********************************************************************}
{*** Seek a dBase III index (.NDX) file returning the first matching ***}
{*** record number. ***}
{*** Entry Conditions: ***}
{*** Passed: N = NDX control record. ***}
{*** Key = alphnumeric Key. ***}
{*** Exit Conditions: ***}
{*** Return: record number of first match. ***}
{***********************************************************************}
Begin {*** NDXseek ***}
If N.H.NumericKey Then
ErrorExit(' Improper alphanumeric Seek.');
NDXseekPrim (N, DummyUserProc, Key, NDXmodeSeekFirst);
NDXseek := N.LastMatch;
End; {*** NDXseek ***}
{****************************************************************************}
Function NDXseekN (Var N: _NDX; Key: Double): Longint;
Begin
If not N.H.NumericKey Then
ErrorExit ('Improper numeric seek.');
NDXseekPrim (N, DummyUserProc, Key, NDXmodeSeekFirst);
NDXseekN := N.LastMatch;
End;
{****************************************************************************}
Procedure NDXTraverse (Var N: _NDX; UserProc: NDXproc);
Const
NullKey: String[1] = '';
Begin
NDXseekPrim (N, UserProc, NullKey, NDXmodeSeekAll);
End;
{****************************************************************************}
End.